home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / eulisp / feel0_89.lha / Feel / Src / basic.c < prev    next >
C/C++ Source or Header  |  1993-06-24  |  6KB  |  249 lines
  1. /* ******************************************************************** */
  2. /*  basic.c          Copyright (C) Codemist and University of Bath 1989 */
  3. /*                                                                      */
  4. /* Basic functions                                            */
  5. /* ******************************************************************** */
  6.  
  7. /*
  8.  * Change Log:
  9.  *   Version 1, April 1989
  10.  *      Add many functions - JPff
  11.  *      Add rplaca & rplacd - RJB
  12.  *      Add defmacro - JPff
  13.  *      Introduce GC protection in places - JPff
  14.  *    Wrote NREVERSE for fun - JPff
  15.  *    and ASSOC - JPff
  16.  *    Moved basic.c to generic.c - JPff
  17.  *    Add defconstant and mutability in bindings - JPff
  18.  *      Hacked car & cons on the nil case and fixed the consp 
  19.  *         make_module_function so that it didn't refer to cons !! - (25/10/89) KJP
  20.  *      Altered defun so that its body is a list of forms - (25/10/89) KJP
  21.  */
  22.  
  23.  
  24. #include "defs.h"
  25. #include "structs.h"
  26. #include "funcalls.h"
  27.  
  28. #include "error.h"
  29. #include "global.h"
  30.  
  31. #include "modboot.h"
  32. #include "specials.h"
  33. #include "weak.h"
  34. #include "streams.h"
  35.  
  36. #ifdef WITH_SYS_TIMES
  37. #include <sys/types.h> /* For paranoia. no sockets => no types */
  38. #include <sys/times.h>
  39. #endif
  40.  
  41. EUFUN_1( Fn_system, str)
  42. {
  43.   if (!is_string(str))
  44.     CallError(stacktop,"system: not a string",str,NONCONTINUABLE);
  45.  
  46.   (void) system(stringof(str));
  47.  
  48.   return(nil);
  49. }
  50. EUFUN_CLOSE
  51.  
  52. EUFUN_1( Fn_getenv, str)
  53. {
  54.   extern char *getenv(char *);
  55.   extern int strlen(char *);
  56.   char *value;
  57.  
  58.   if (!is_string(str))
  59.     CallError(stacktop,"getenv: not a string",str,NONCONTINUABLE);
  60.  
  61.   value = getenv(stringof(str));
  62.  
  63.   if (value == NULL) return(nil);
  64.  
  65.   return((LispObject) allocate_string(stacktop,value,strlen(value)));
  66. }
  67. EUFUN_CLOSE
  68.  
  69. EUFUN_0( Fn_exit)
  70. {
  71.   print_string(stacktop,StdOut(),"\n\nExiting EuLisp\n\n");
  72.   
  73.   system_lisp_exit(0);
  74.  
  75.   return(nil);
  76. }
  77. EUFUN_CLOSE
  78.  
  79. EUFUN_0( Fn_make_map)
  80. {
  81.   extern void make_description_file(LispObject *);
  82.  
  83.   make_description_file(stacktop);
  84.  
  85.   return(nil);
  86. }
  87. EUFUN_CLOSE
  88.  
  89. /* Time... */
  90.  
  91. #include <sys/types.h>
  92.  
  93. EUFUN_0( Fn_system_time)
  94. {
  95.   extern long time(long *);
  96.   long n;
  97.  
  98.   (void) time(&n);
  99.   return(allocate_integer(stackbase, (int) n));
  100. }
  101. EUFUN_CLOSE
  102.  
  103. EUFUN_0( Fn_process_id)
  104. {
  105.   extern int getpid(void);
  106.   int xx;
  107.   xx = getpid();
  108.   return(allocate_integer(stackbase,xx));
  109. }
  110. EUFUN_CLOSE
  111.  
  112. EUFUN_0( Fn_backtrace)
  113. {
  114.   extern void module_eval_backtrace(LispObject *);
  115.   module_eval_backtrace(stacktop);
  116.   return(nil);
  117. }
  118. EUFUN_CLOSE
  119.  
  120. EUFUN_0( Fn_cpu_time)
  121. {
  122.   extern long clock(void);
  123.   int xx;
  124.   xx=(int)(clock()/10000);
  125.   return(allocate_integer(stackbase,xx));
  126. }
  127. EUFUN_CLOSE
  128.  
  129. #ifdef WITH_SYS_TIMES
  130. EUFUN_0(Fn_sys_times)
  131. {
  132.   struct tms time_vals;
  133.   long total_time;
  134.   LispObject vals,tmp;
  135.   
  136.   total_time=times(&time_vals);
  137.   vals=allocate_vector(stacktop,3);
  138.   STACK_TMP(vals);
  139.   tmp=allocate_integer(stacktop,total_time);
  140.   UNSTACK_TMP(vals);
  141.   vref(vals,0)=tmp;
  142.   STACK_TMP(vals);
  143.   tmp=allocate_integer(stacktop,time_vals.tms_utime);
  144.   UNSTACK_TMP(vals);
  145.   vref(vals,1)=tmp;
  146.   STACK_TMP(vals);
  147.   tmp=allocate_integer(stacktop,time_vals.tms_stime);
  148.   UNSTACK_TMP(vals);
  149.   vref(vals,2)=tmp;
  150.   
  151.   return vals;
  152. }
  153. EUFUN_CLOSE
  154. #endif
  155. EUFUN_1( Fn_system_describe, obj)
  156. {
  157.   printf("Address: %x\n",(int) obj);
  158.   printf("Type: %x\n",typeof(obj));
  159.   printf("GC: %x\n",gcof(obj));
  160.   printf("Class: %x\n",(int) classof(obj));
  161.   fflush(stdout);
  162.   return(nil);
  163. }
  164. EUFUN_CLOSE
  165.  
  166. /* Weak pointers... */
  167.  
  168. extern LispObject allocate_weak_wrapper(LispObject*, LispObject);
  169.  
  170. EUFUN_1( Fn_make_weak_wrapper, obj)
  171. {
  172.   LispObject tmp;
  173.   tmp=EUCALL_2(Fn_cons,obj,nil);
  174.   lval_classof(tmp)=Weak_Wrapper;
  175.   lval_typeof(tmp)=TYPE_WEAK_WRAPPER;
  176.   return(tmp);
  177. }
  178. EUFUN_CLOSE
  179.  
  180. EUFUN_1( Fn_weak_wrapper_ref, w)
  181. {
  182.   if (!is_weak_wrapper(w))
  183.     CallError(stacktop,
  184.           "weak-wrapper-ref: not a weak wrapper",w,NONCONTINUABLE);
  185.  
  186.   return(weak_ptr_val(w));
  187. }
  188. EUFUN_CLOSE
  189.  
  190. EUFUN_2 (Fn_weak_wrapper_ref_setter, w, obj)
  191. {
  192.   if (!is_weak_wrapper(w))
  193.     CallError(stacktop,"(setter weak-wrapper-ref): not a weak wrapper",
  194.           w,NONCONTINUABLE);  
  195.  
  196.   weak_ptr_val(w) = obj;
  197.  
  198.   return(obj);
  199. }
  200. EUFUN_CLOSE
  201.  
  202. LispObject Cb_GC_hook;
  203.  
  204. EUFUN_1(Fn_set_post_gc_callback,val)
  205. {
  206.   CAR(Cb_GC_hook)=val;
  207.   return nil;
  208. }
  209. EUFUN_CLOSE
  210. /* *************************************************************** */
  211. /* Initialisation of this section                                  */
  212. /* *************************************************************** */
  213.  
  214. void initialise_basic(LispObject *stacktop)
  215. {
  216.   LispObject get,set;
  217.   Cb_GC_hook=EUCALL_2(Fn_cons,nil,nil);
  218.   add_root(&Cb_GC_hook);
  219.   (void) make_module_function(stacktop,"special-operator-p",Fn_special_form_p,1);
  220.   get = make_module_function(stacktop,"symbol-dynamic-value",Fn_dynamic,1);
  221.   STACK_TMP(get);
  222.   set = make_unexported_module_function(stacktop,"symbol-dynamic-value-updator",
  223.                     Fn_dynamic_setq,2);
  224.   UNSTACK_TMP(get);
  225.   set_anon_associate(stacktop,get,set);
  226.  
  227.   (void) make_module_function(stacktop,"system",Fn_system,1);
  228.   (void) make_module_function(stacktop,"getenv",Fn_getenv,1);
  229.   (void) make_module_function(stacktop,"exit",Fn_exit,0);
  230.   (void) make_module_function(stacktop,"make-map",Fn_make_map,0);
  231.   (void) make_module_function(stacktop,"system-time",Fn_system_time,0);
  232.   (void) make_module_function(stacktop,"process-id",Fn_process_id,0);
  233.   (void) make_module_function(stacktop,"backtrace",Fn_backtrace,0);
  234.   (void) make_module_function(stacktop,"cpu-time",Fn_cpu_time,0);
  235.  
  236.   (void) make_module_function(stacktop,"system-print",Fn_system_describe,1);
  237.   (void) make_module_function(stacktop,"make-weak-wrapper",Fn_make_weak_wrapper,1);
  238.   get = make_module_function(stacktop,"weak-wrapper-ref",Fn_weak_wrapper_ref,1);
  239.   STACK_TMP(get);
  240.   set = make_module_function(stacktop,"(setter weak-wrapper-ref)",
  241.                  Fn_weak_wrapper_ref_setter,2);
  242.   UNSTACK_TMP(get);
  243.   set_anon_associate(stacktop,get,set);
  244.   (void) make_module_function(stacktop,"set-post-gc-callback",Fn_set_post_gc_callback,1);
  245. #ifdef WITH_SYS_TIMES
  246.   (void) make_module_function(stacktop,"cpu-times",Fn_sys_times,0);
  247. #endif
  248. }
  249.